source: WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDD43.m@ 1504

ORDD43 ; SLC/MKB - Build xrefs for file 101.43 ;7/2/97  10:52
 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**26,68,94,164,190**;Dec 17, 1997
 ;
SET(X,IFN) ; Create new entry X in SET multiple
 N DIC,DA,Y Q:$D(^ORD(101.43,IFN,9,"B",X))  ; already exists
 S DIC="^ORD(101.43,"_IFN_",9,",DIC(0)="L",DA(1)=IFN
 S DIC("P")=$P(^DD(101.43,9,0),U,2) K DD,DO
 S ^ORD(101.43,"AH",X)=$H
 S ^ORD(101.43,"AH","S."_X)=$H
 D FILE^DICN
 Q
 ;
KILL(X,IFN) ; Remove entry X from SET multiple
 N DIK,DA
 S DIK="^ORD(101.43,"_IFN_",9,",DA(1)=IFN
 S ^ORD(101.43,"AH",X)=$H
 S DA=$O(^ORD(101.43,IFN,9,"B",X,0)) I DA D ^DIK
 Q
 ;
SETRA(NAME,ITYPE,CPROC) ; Set COMMON xref
 Q:'CPROC  Q:'$L(ITYPE)  ; not common, no IType
 S ^ORD(101.43,"COMMON",ITYPE,NAME,DA)=""
 Q
 ;
KILLRA(NAME,ITYPE,CPROC) ; Kill COMMON xref
 Q:'CPROC  Q:'$L(ITYPE)  ; not common, no IType
 K ^ORD(101.43,"COMMON",ITYPE,NAME,DA)
 Q
 ;
SS(NAME,DATE,LABTYP) ; -- Set S.SET xref by Name, Set multiple
 Q:'$L($G(NAME))  I ($G(LABTYP)="O")!($G(LABTYP)="N") D SK(NAME) Q
 N SET,SET0,SETNM,SETLST,QO
 S SET=0 F  S SET=$O(^ORD(101.43,DA,9,SET)) Q:SET'>0  S SET0=$G(^(SET,0)) D
 . S SETNM=$P(SET0,U),QO=$P(SET0,U,2)
 . S ^ORD(101.43,"S."_SETNM,$$UP^XLFSTR(NAME),DA)=U_NAME_U_$G(DATE)_U_U_QO
 . S ^ORD(101.43,"AH","S."_SETNM)=$H,SETLST("S."_SETNM)=""
 I $G(DATE),(DATE>$$NOW^XLFDT) D
 . N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE,ZTSK
 . S ZTRTN="DQAH^ORDD43",ZTDESC="CPRS AH Update",ZTDTH=DATE,ZTIO=""
 . S ZTSAVE("SETLST(")="" D ^%ZTLOAD
 Q
DQAH ; -- set new timestamps for sets where items are becoming inactive
 S ZTREQ="@"
 N X
 S X="" F  S X=$O(SETLST(X)) Q:X=""  S ^ORD(101.43,"AH",X)=$H
 Q
 ;
SK(NAME) ; -- Kill S.SET xref by Name, Set multiple
 Q:'$L($G(NAME))  N SET,SETNM
 S SET=0 F  S SET=$O(^ORD(101.43,DA,9,SET)) Q:SET'>0  S SETNM=$P(^(SET,0),U) D
 . K ^ORD(101.43,"S."_SETNM,$$UP^XLFSTR(NAME),DA)
 . S ^ORD(101.43,"AH","S."_SETNM)=$H
 Q
 ;
SS1(NAME,DATE,LABTYP) ; -- Set S.SET mnemonic xref by Synonym, Name, Set
 Q:'$L($G(NAME))  I ($G(LABTYP)="O")!($G(LABTYP)="N") D SK1(NAME) Q
 N SYN,SYNM,SET,SET0,SETNM,QO
 S SET=0 F  S SET=$O(^ORD(101.43,DA,9,SET)) Q:SET'>0  S SET0=$G(^(SET,0)) D
 . S SETNM=$P(SET0,U),QO=$P(SET0,U,2)
 . S SYN=0 F  S SYN=$O(^ORD(101.43,DA,2,SYN)) Q:SYN'>0  S SYNM=$P(^(SYN,0),U) D
 . . S:SYNM'=NAME ^ORD(101.43,"S."_SETNM,$$UP^XLFSTR(SYNM),DA)="1^"_SYNM_U_$G(DATE)_U_NAME_U_QO
 . . S ^ORD(101.43,"AH","S."_SETNM)=$H
 Q
 ;
SK1(NAME) ; -- Kill S.SET mnemonic xref by Synonym, Name, Set
 N SYN,SYNM,SET,SETNM
 S SET=0 F  S SET=$O(^ORD(101.43,DA,9,SET)) Q:SET'>0  S SETNM=$P(^(SET,0),U) D
 . S SYN=0 F  S SYN=$O(^ORD(101.43,DA,2,SYN)) Q:SYN'>0  S SYNM=$P(^(SYN,0),U) D
 . . I $G(^ORD(101.43,"S."_SETNM,$$UP^XLFSTR(SYNM),DA)) K ^(DA)
 . . S ^ORD(101.43,"AH","S."_SETNM)=$H
 Q
 ;
SS2 ; -- Set S.SET mnemonic xref from SET multiple
 N TYP,NAME,DATE,SYN,SYNM,I,QO
 S TYP=$P($G(^ORD(101.43,DA(1),"LR")),U,7) I (TYP="O")!(TYP="N") D SK2 Q
 S I=+$O(^ORD(101.43,DA(1),9,"B",X,0))
 S QO=$P($G(^ORD(101.43,DA(1),9,I,0)),U,2)
 S SYN=0,NAME=$P(^ORD(101.43,DA(1),0),U),DATE=$G(^(.1))
 F  S SYN=$O(^ORD(101.43,DA(1),2,SYN)) Q:SYN'>0  S SYNM=$P(^(SYN,0),U) D
 . S:SYNM'=NAME ^ORD(101.43,"S."_X,$$UP^XLFSTR(SYNM),DA(1))="1^"_SYNM_U_DATE_U_NAME_U_QO
 . S ^ORD(101.43,"AH","S."_X)=$H
 Q
 ;
SK2 ; -- Kill S.SET mnemonic xref from SET multiple
 N SYN,SYNM
 S SYN=0 F  S SYN=$O(^ORD(101.43,DA(1),2,SYN)) Q:SYN'>0  S SYNM=$P(^(SYN,0),U) D
 . I $G(^ORD(101.43,"S."_X,$$UP^XLFSTR(SYNM),DA(1))) K ^(DA(1))
 . S ^ORD(101.43,"AH","S."_X)=$H
 Q
 ;
SS3 ; -- Set S.SET mnemonic xref from SYN multiple
 N TYP,NAME,DATE,SET,SET0,SETNM,QO
 S TYP=$P($G(^ORD(101.43,DA(1),"LR")),U,7) I (TYP="O")!(TYP="N") D SK3 Q
 S NAME=$P(^ORD(101.43,DA(1),0),U),DATE=$G(^(.1)),SET=0 Q:X=NAME
 F  S SET=$O(^ORD(101.43,DA(1),9,SET)) Q:SET'>0  S SET0=$G(^(SET,0)) D
 . S SETNM=$P(SET0,U),QO=$P(SET0,U,2)
 . S ^ORD(101.43,"S."_SETNM,$$UP^XLFSTR(X),DA(1))="1^"_X_U_DATE_U_NAME_U_QO
 . S ^ORD(101.43,"AH","S."_SETNM)=$H
 Q
 ;
SK3 ; -- Kill S.SET mnemonic xref from SYN multiple
 N SET,SETNM
 S SET=0 F  S SET=$O(^ORD(101.43,DA(1),9,SET)) Q:SET'>0  S SETNM=$P(^(SET,0),U) D
 . I $G(^ORD(101.43,"S."_SETNM,$$UP^XLFSTR(X),DA(1))) K ^(DA(1))
 . S ^ORD(101.43,"AH","S."_SETNM)=$H
 Q
 ;
CS(NAME,CODE,DATE) ; -- Set C.SET xref by 'Code Name', Set
 Q:'$L($G(NAME))  Q:'$L($G(CODE))
 N X,XP,ORS,SET0,SETNM,QO
 S X=CODE_" "_NAME,XP=$$UP^XLFSTR(X)
 S ORS=0 F  S ORS=$O(^ORD(101.43,DA,9,ORS)) Q:ORS'>0  S SET0=$G(^(ORS,0)) D
 . S SETNM=$P(SET0,U),QO=$P(SET0,U,2)
 . S ^ORD(101.43,"C."_SETNM,XP,DA)=U_X_U_$G(DATE)_U_U_QO
 Q
 ;
CK(NAME,CODE) ; -- Kill C.SET xref
 Q:'$L($G(NAME))  Q:'$L($G(CODE))
 N XP,ORS,ORSET S XP=$$UP^XLFSTR(CODE_" "_NAME)
 S ORS=0 F  S ORS=$O(^ORD(101.43,DA,9,ORS)) Q:ORS'>0  S ORSET=$P(^(ORS,0),U) K ^ORD(101.43,"C."_ORSET,XP,DA)
 Q
 ;
QO(X) ; -- Add data to SET xrefs, set/kill AQO xref
 N NAME,XREF,SYN,SYNM S X=$G(X)
 S NAME=$$UP^XLFSTR($P($G(^ORD(101.43,DA(1),0)),U)),XREF="S."_$P($G(^(9,DA,0)),U)
 S:X ^ORD(101.43,DA(1),9,"AQO",XREF)=""
 K:'X ^ORD(101.43,DA(1),9,"AQO",XREF)
 Q:'$D(^ORD(101.43,XREF,NAME,DA(1)))  S $P(^(DA(1)),U,5)=X
 S SYN=0 F  S SYN=+$O(^ORD(101.43,DA(1),2,SYN)) Q:SYN<1  S SYNM=$P($G(^(SYN,0)),U),$P(^ORD(101.43,XREF,$$UP^XLFSTR(SYNM),DA(1)),U,5)=X
 S ^ORD(101.43,"AH",XREF)=$H
 Q
 ;
XHELP(INDEX,SCREEN) ; -- ??Help
 N X,Y,Y0,Z,SYN,CNT,D,DONE
 S:'$L($G(INDEX)) INDEX="B" W !!,"Choose from:" S CNT=1,D=INDEX
 S X="" F  S X=$O(^ORD(101.43,INDEX,X)) Q:X=""  S Y=0 D  Q:$G(DONE)
 . F  S Y=$O(^ORD(101.43,INDEX,X,Y)) Q:Y'>0  S SYN=$G(^(Y)) I 'SYN D  Q:$G(DONE)
 . . S Y0=$G(^ORD(101.43,Y,0)) X:$L($G(SCREEN)) SCREEN Q:'$T
 . . W !,"   "_X ;W:SYN "     "_$P(SYN,U,4) ; echo .01 if synonym
 . . S CNT=CNT+1 Q:CNT'>(IOSL-5)  S CNT=0
 . . W !,"   '^' TO STOP: " R Z:DTIME S:'$T!(Z["^") DONE=1
 W !
 Q
 ;
ACTIVE(ITM) ; -- Screen, if inactive or restricted to QO use only
 ;        Use in DIC("S") when searching #101.43
 N Y S Y=1
 I $G(ORTYPE)="D",$L($G(D)),$D(^ORD(101.43,+ITM,9,"AQO",$P(D,U))) S Y=0
 I $G(^ORD(101.43,+ITM,.1)),^(.1)'>$$NOW^XLFDT S Y=0  ;inactive
 Q Y
 ;
ID(OLD,NEW) ; -- API for package to update ID field [ code;99XXX ]
 ;    Returns 1 or 0, if successful or not
 N IFN,Y S Y=0
 G:'$G(OLD) IDQ G:$G(NEW)'?1.N1";99"3U IDQ ;invalid
 S IFN=+$O(^ORD(101.43,"ID",OLD,0)) G:IFN'>0 IDQ
 K ^ORD(101.43,"ID",OLD,IFN)
 S $P(^ORD(101.43,IFN,0),U,2)=NEW,^ORD(101.43,"ID",NEW,IFN)="",Y=1
IDQ Q Y