PSGAL5 ;BIR/CML3 - ACTIVITY LOGGER ;22 Jan 99 / 8:00 AM
;;5.0;INPATIENT MEDICATIONS;**3,22,50,267,316**;16 DEC 97;Build 8
;
;Reference to ^PS(55 is supported by DBIA 2191
;Reference to ^DD is supported by DBIA 903
;
EN ;
N PSJ9,PSJ99 F Q=1:1 Q:'$D(DA(Q+1))
S PSGAL("D0")=DA(Q),PSGAL("D1")=$S(Q=1:DA,1:DA(Q-1)) Q:PSGAL("D0")["U"
I PSGAL("C")'=6000,$D(PSGALO),PSGALO S PSGAL("C")=PSGALO
I PSGAL("C")=6000,$D(PSGALR),PSGALR]"" S PSGAL("C")=PSGAL("C")+PSGALR
I $E(PSGAL("C"),1,2)=60 S OLD=X,FLD=$S($D(PSGALFF):PSGALFF,1:0),FN=$S($D(PSGALFN):PSGALFN,1:55.06) D FIELD^DID(FN,FLD,,"SPECIFIER","PSJ9") I OLD]"",$G(PSJ9("SPECIFIER"))["P" S XX=FN,YY=FLD D PNTR
I $E(PSGAL("C"),1,2)=60,OLD]"" D FIELD^DID(FN,FLD,,"SPECIFIER","PSJ9") I $G(PSJ9("SPECIFIER"))["S" S OLDS=$P($P(";"_$P(^DD(FN,FLD,0),"^",3),";"_OLD_":",2),";") I OLDS]"" S OLD=OLDS
S QQ=$G(^PS(55,PSGAL("D0"),5,PSGAL("D1"),9,0)) S:QQ="" QQ="^55.09D" F Q=$P(QQ,"^",3)+1:1 I '$D(^(Q)) S $P(QQ,"^",3,4)=Q_"^"_Q,^(0)=QQ,PSGAL("N")=Q Q
D NOW^%DTC S PSGDT=+$E(%,1,12)
S Q=%_"^"_$S(PSGAL("C")=6010:"AUTO CANCEL",$D(DUZ)[0:"UNKNOWN",DUZ]"":DUZ,1:"UNKNOWN")_"^"_PSGAL("C")_$S($E(PSGAL("C"),1,2)=60:"^"_$S('$D(^DD(FN,FLD,0)):FLD,$P(^(0),"^")]"":$P(^(0),"^"),1:FLD)_"^"_OLD,1:"")
I Q'["SPECIAL INSTRUCTIONS" S ^PS(55,PSGAL("D0"),5,PSGAL("D1"),9,PSGAL("N"),0)=Q I PSGAL("C")=6000,$D(PSGALEF) S PSGALEF=PSGALEF+1
I Q["SPECIAL INSTRUCTIONS",$$DIFFSI^PSJBCMA5(PSGAL("D0"),PSGAL("D1")) D
.Q:'$G(PSJSYSP) Q:($G(^PS(53.45,PSJSYSP,5))="AL")
.S ^PS(55,PSGAL("D0"),5,PSGAL("D1"),9,PSGAL("N"),0)=Q
.S ^PS(55,PSGAL("D0"),5,PSGAL("D1"),9,PSGAL("N"),1,0)=$G(^PS(55,PSGAL("D0"),5,PSGAL("D1"),15,0))
.N LN S LN=0 F S LN=$O(^PS(55,PSGAL("D0"),5,PSGAL("D1"),15,LN)) Q:'LN D
..S ^PS(55,PSGAL("D0"),5,PSGAL("D1"),9,PSGAL("N"),1,LN,0)=^PS(55,PSGAL("D0"),5,PSGAL("D1"),15,LN,0)
;
DONE ;
S PSGAL("D")=% K OLDS,FLD,FN,OLD,PSGALFF,PSGALFN,SS,XX,YY Q
;
PNTR ; find pointer value
F D FIELD^DID(XX,YY,,"POINTER","PSJ99") S SS=PSJ99("POINTER"),XX=+$P(@("^"_SS_"0)"),"^",2),OLD=$P(@("^"_SS_OLD_",0)"),"^") D FIELD^DID(XX,.01,,"SPECIFIER","PSJ99") Q:$G(PSJ99("SPECIFIER"))'["P" S YY=.01
Q
;
KILL ; if user merely reenters same data (tsk, tsk), kill record just written
I Q["SPECIAL INSTRUCTIONS" Q:$$COMPSI()
K ^PS(55,PSGAL("D0"),5,PSGAL("D1"),9,PSGAL("N"),0) I PSGAL("C")=6000,$D(PSGALEF),PSGALEF S PSGALEF=PSGALEF-1
Q
;
COMPSI() ; Compare old Special Instructions (long) to new Special Instructions (long)
N Q2,DIFF Q:'$G(DUZ) 0
S DIFF=0,Q2=0 F S Q2=$O(^PS(55,PSGAL("D0"),5,PSGAL("D1"),15,Q2)) Q:'Q2!$G(DIFF) D
.I $G(^PS(53.45,DUZ,5,Q2,0))'=^PS(55,PSGAL("D0"),5,PSGAL("D1"),15,Q2,0) S DIFF=1
Q $S(DIFF:1,1:0)
;
; Create new activity log entry in file #55.
NEWUDAL(PSGALGP,PSGALORD,PSGALC,PSGFLD,PSGOLD,PSGOLDAR) ;
;
;Where PSGALGP = PSGP (Required)
; PSGALORD = PSGORD (Required)
; PSGALC = ACTIVITY CODE FROM #53.3 (Required)
; PSGFLD = FIELD THAT CHANGED (Free text, optional)
; PSGOLD = THE FIELDS OLD DATA VALUE (Free text, optional)
;
; Create 0 node activity log for order if not exists, and get next entry number
Q:PSGALGP["U"
S QQ=$G(^PS(55,PSGALGP,5,+PSGALORD,9,0)) S:QQ="" QQ="^55.09D" F Q=$P(QQ,"^",3)+1:1 I '$D(^(Q)) S $P(QQ,"^",3,4)=Q_"^"_Q,^(0)=QQ,PSGAL("N")=Q Q
;Set up data to be held in activity log record
D NOW^%DTC S PSGDT=+$E(%,1,12)
I $L($G(PSGOLD))>170 S PSGOLD=$E(PSGOLD,1,167)_"..." ; Use of ... indicates old data field was greater than 170 characters
S Q=%_"^"_$S(PSGALC=6010:"AUTO CANCEL",$D(DUZ)[0:"UNKNOWN",DUZ]"":DUZ,1:"UNKNOWN")_"^"_PSGALC_"^"_$S($D(PSGFLD):PSGFLD,1:"")_"^"_$S($D(PSGOLD):PSGOLD,1:"")
; Create activity log entry
S ^PS(55,PSGALGP,5,+PSGALORD,9,PSGAL("N"),0)=Q
I $D(PSGOLDAR),$$DIFFSI^PSJBCMA5(PSGALGP,PSGALORD) D
.S ^PS(55,PSGALGP,5,+PSGALORD,9,PSGAL("N"),1,0)=PSGOLDAR(0)
.N LN S LN=0 F S LN=$O(PSGOLDAR(LN)) Q:'LN D
..S ^PS(55,PSGALGP,5,+PSGALORD,9,PSGAL("N"),1,LN,0)=PSGOLDAR(LN,0)
.N LN S LN=0 F S LN=$O(^PS(53.45,+$G(PSJSYSP),5,LN)) Q:'LN D
..S ^PS(55,PSGALGP,5,+PSGALORD,9,PSGAL("N"),2,LN,0)=^PS(53.45,+$G(PSJSYSP),5,LN,0)
.S ^PS(53.45,+$G(PSJSYSP),5)="AL"
Q
; Create new activity log entry
NEWNVAL(PSGALORD,PSGALC,PSGFLD,PSGOLD,PSGOLDAR) ;
;
;Where PSGALORD = PSGORD (Required)
; PSGALC = ACTIVITY CODE FROM #53.3 (Required)
; PSGFLD = FIELD THAT CHANGED (Free text, optional)
; PSGOLD = THE FIELDS OLD DATA VALUE (Free text, optional)
; PSGOLDAR = THE FIELDS OLD DATA VALUE, IF WP FIELD (array, optional)
;
;N PSGALORD,PSGALC,PSGFLD,PSGOLD
;
; Create 0 node activity log for order if not exists, and get next entry number
S QQ=$G(^PS(53.1,+PSGALORD,"A",0)) S:QQ="" QQ="^53.1119D" F Q=$P(QQ,"^",3)+1:1 I '$D(^(Q)) S $P(QQ,"^",3,4)=Q_"^"_Q,^(0)=QQ,PSGAL("N")=Q Q
;Set up data to be held in activity log record
D NOW^%DTC S PSGDT=+$E(%,1,12)
I $L($G(PSGOLD))>170 S PSGOLD=$E(PSGOLD,1,167)_"..." ; Use of ... indicates old data field was greater than 170 characters
S Q=%_"^"_$S(PSGALC=6010:"AUTO CANCEL",$D(DUZ)[0:"UNKNOWN",DUZ]"":DUZ,1:"UNKNOWN")_"^"_PSGALC_"^"_$S($D(PSGFLD):PSGFLD,1:"")_"^"_$S($D(PSGOLD):PSGOLD,1:"")
; Create activity log entry
S ^PS(53.1,+PSGALORD,"A",PSGAL("N"),0)=Q
I $D(PSGOLDAR)&(Q["SPECIAL INSTRUCTIONS"!(Q["OTHER PRINT INFO")) D
.I Q["SPECIAL INSTRUCTIONS" Q:'$$DIFFSI^PSJBCMA5(+$G(DFN),PSGALORD)
.I Q["OTHER PRINT INFO" Q:'$$DIFFOPI^PSJBCMA5(+$G(DFN),PSGALORD)
.N LNCNT S LNCNT=$O(PSGOLDAR(""),-1) S ^PS(53.1,+PSGALORD,"A",PSGAL("N"),1,0)="^53.11195^"_+LNCNT_"^"_+LNCNT,^(1,0)=" "
.N LN S LN=0 F S LN=$O(PSGOLDAR(LN)) Q:'LN S ^PS(53.1,+PSGALORD,"A",PSGAL("N"),1,LN,0)=PSGOLDAR(LN,0)
Q
;
KILLNV ; if user merely reenters same data (tsk, tsk), kill record just written
K ^PS(53.1,PSGAL("D0"),"A",PSGAL("N"),0) I PSGAL("C")=6000,$D(PSGALEF),PSGALEF S PSGALEF=PSGALEF-1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGAL5 5931 printed Dec 13, 2024@02:00:42 Page 2
PSGAL5 ;BIR/CML3 - ACTIVITY LOGGER ;22 Jan 99 / 8:00 AM
+1 ;;5.0;INPATIENT MEDICATIONS;**3,22,50,267,316**;16 DEC 97;Build 8
+2 ;
+3 ;Reference to ^PS(55 is supported by DBIA 2191
+4 ;Reference to ^DD is supported by DBIA 903
+5 ;
EN ;
+1 NEW PSJ9,PSJ99
FOR Q=1:1
if '$DATA(DA(Q+1))
QUIT
+2 SET PSGAL("D0")=DA(Q)
SET PSGAL("D1")=$SELECT(Q=1:DA,1:DA(Q-1))
if PSGAL("D0")["U"
QUIT
+3 IF PSGAL("C")'=6000
IF $DATA(PSGALO)
IF PSGALO
SET PSGAL("C")=PSGALO
+4 IF PSGAL("C")=6000
IF $DATA(PSGALR)
IF PSGALR]""
SET PSGAL("C")=PSGAL("C")+PSGALR
+5 IF $EXTRACT(PSGAL("C"),1,2)=60
SET OLD=X
SET FLD=$SELECT($DATA(PSGALFF):PSGALFF,1:0)
SET FN=$SELECT($DATA(PSGALFN):PSGALFN,1:55.06)
DO FIELD^DID(FN,FLD,,"SPECIFIER","PSJ9")
IF OLD]""
IF $GET(PSJ9("SPECIFIER"))["P"
SET XX=FN
SET YY=FLD
DO PNTR
+6 IF $EXTRACT(PSGAL("C"),1,2)=60
IF OLD]""
DO FIELD^DID(FN,FLD,,"SPECIFIER","PSJ9")
IF $GET(PSJ9("SPECIFIER"))["S"
SET OLDS=$PIECE($PIECE(";"_$PIECE(^DD(FN,FLD,0),"^",3),";"_OLD_":",2),";")
IF OLDS]""
SET OLD=OLDS
+7 SET QQ=$GET(^PS(55,PSGAL("D0"),5,PSGAL("D1"),9,0))
if QQ=""
SET QQ="^55.09D"
FOR Q=$PIECE(QQ,"^",3)+1:1
IF '$DATA(^(Q))
SET $PIECE(QQ,"^",3,4)=Q_"^"_Q
SET ^(0)=QQ
SET PSGAL("N")=Q
QUIT
+8 DO NOW^%DTC
SET PSGDT=+$EXTRACT(%,1,12)
+9 SET Q=%_"^"_$SELECT(PSGAL("C")=6010:"AUTO CANCEL",$DATA(DUZ)[0:"UNKNOWN",DUZ]"":DUZ,1:"UNKNOWN")_"^"_PSGAL("C")_$SELECT($EXTRACT(PSGAL("C"),1,2)=60:"^"_$SELECT('$DATA(^DD(FN,FLD,0)):FLD,$PIECE(^(0),"^")]"":$PIECE(^(0),"^"),1:FLD)_"^"_OLD,1:"")
+10 IF Q'["SPECIAL INSTRUCTIONS"
SET ^PS(55,PSGAL("D0"),5,PSGAL("D1"),9,PSGAL("N"),0)=Q
IF PSGAL("C")=6000
IF $DATA(PSGALEF)
SET PSGALEF=PSGALEF+1
+11 IF Q["SPECIAL INSTRUCTIONS"
IF $$DIFFSI^PSJBCMA5(PSGAL("D0"),PSGAL("D1"))
Begin DoDot:1
+12 if '$GET(PSJSYSP)
QUIT
if ($GET(^PS(53.45,PSJSYSP,5))="AL")
QUIT
+13 SET ^PS(55,PSGAL("D0"),5,PSGAL("D1"),9,PSGAL("N"),0)=Q
+14 SET ^PS(55,PSGAL("D0"),5,PSGAL("D1"),9,PSGAL("N"),1,0)=$GET(^PS(55,PSGAL("D0"),5,PSGAL("D1"),15,0))
+15 NEW LN
SET LN=0
FOR
SET LN=$ORDER(^PS(55,PSGAL("D0"),5,PSGAL("D1"),15,LN))
if 'LN
QUIT
Begin DoDot:2
+16 SET ^PS(55,PSGAL("D0"),5,PSGAL("D1"),9,PSGAL("N"),1,LN,0)=^PS(55,PSGAL("D0"),5,PSGAL("D1"),15,LN,0)
End DoDot:2
End DoDot:1
+17 ;
DONE ;
+1 SET PSGAL("D")=%
KILL OLDS,FLD,FN,OLD,PSGALFF,PSGALFN,SS,XX,YY
QUIT
+2 ;
PNTR ; find pointer value
+1 FOR
DO FIELD^DID(XX,YY,,"POINTER","PSJ99")
SET SS=PSJ99("POINTER")
SET XX=+$PIECE(@("^"_SS_"0)"),"^",2)
SET OLD=$PIECE(@("^"_SS_OLD_",0)"),"^")
DO FIELD^DID(XX,.01,,"SPECIFIER","PSJ99")
if $GET(PSJ99("SPECIFIER"))'["P"
QUIT
SET YY=.01
+2 QUIT
+3 ;
KILL ; if user merely reenters same data (tsk, tsk), kill record just written
+1 IF Q["SPECIAL INSTRUCTIONS"
if $$COMPSI()
QUIT
+2 KILL ^PS(55,PSGAL("D0"),5,PSGAL("D1"),9,PSGAL("N"),0)
IF PSGAL("C")=6000
IF $DATA(PSGALEF)
IF PSGALEF
SET PSGALEF=PSGALEF-1
+3 QUIT
+4 ;
COMPSI() ; Compare old Special Instructions (long) to new Special Instructions (long)
+1 NEW Q2,DIFF
if '$GET(DUZ)
QUIT 0
+2 SET DIFF=0
SET Q2=0
FOR
SET Q2=$ORDER(^PS(55,PSGAL("D0"),5,PSGAL("D1"),15,Q2))
if 'Q2!$GET(DIFF)
QUIT
Begin DoDot:1
+3 IF $GET(^PS(53.45,DUZ,5,Q2,0))'=^PS(55,PSGAL("D0"),5,PSGAL("D1"),15,Q2,0)
SET DIFF=1
End DoDot:1
+4 QUIT $SELECT(DIFF:1,1:0)
+5 ;
+6 ; Create new activity log entry in file #55.
NEWUDAL(PSGALGP,PSGALORD,PSGALC,PSGFLD,PSGOLD,PSGOLDAR) ;
+1 ;
+2 ;Where PSGALGP = PSGP (Required)
+3 ; PSGALORD = PSGORD (Required)
+4 ; PSGALC = ACTIVITY CODE FROM #53.3 (Required)
+5 ; PSGFLD = FIELD THAT CHANGED (Free text, optional)
+6 ; PSGOLD = THE FIELDS OLD DATA VALUE (Free text, optional)
+7 ;
+8 ; Create 0 node activity log for order if not exists, and get next entry number
+9 if PSGALGP["U"
QUIT
+10 SET QQ=$GET(^PS(55,PSGALGP,5,+PSGALORD,9,0))
if QQ=""
SET QQ="^55.09D"
FOR Q=$PIECE(QQ,"^",3)+1:1
IF '$DATA(^(Q))
SET $PIECE(QQ,"^",3,4)=Q_"^"_Q
SET ^(0)=QQ
SET PSGAL("N")=Q
QUIT
+11 ;Set up data to be held in activity log record
+12 DO NOW^%DTC
SET PSGDT=+$EXTRACT(%,1,12)
+13 ; Use of ... indicates old data field was greater than 170 characters
IF $LENGTH($GET(PSGOLD))>170
SET PSGOLD=$EXTRACT(PSGOLD,1,167)_"..."
+14 SET Q=%_"^"_$SELECT(PSGALC=6010:"AUTO CANCEL",$DATA(DUZ)[0:"UNKNOWN",DUZ]"":DUZ,1:"UNKNOWN")_"^"_PSGALC_"^"_$SELECT($DATA(PSGFLD):PSGFLD,1:"")_"^"_$SELECT($DATA(PSGOLD):PSGOLD,1:"")
+15 ; Create activity log entry
+16 SET ^PS(55,PSGALGP,5,+PSGALORD,9,PSGAL("N"),0)=Q
+17 IF $DATA(PSGOLDAR)
IF $$DIFFSI^PSJBCMA5(PSGALGP,PSGALORD)
Begin DoDot:1
+18 SET ^PS(55,PSGALGP,5,+PSGALORD,9,PSGAL("N"),1,0)=PSGOLDAR(0)
+19 NEW LN
SET LN=0
FOR
SET LN=$ORDER(PSGOLDAR(LN))
if 'LN
QUIT
Begin DoDot:2
+20 SET ^PS(55,PSGALGP,5,+PSGALORD,9,PSGAL("N"),1,LN,0)=PSGOLDAR(LN,0)
End DoDot:2
+21 NEW LN
SET LN=0
FOR
SET LN=$ORDER(^PS(53.45,+$GET(PSJSYSP),5,LN))
if 'LN
QUIT
Begin DoDot:2
+22 SET ^PS(55,PSGALGP,5,+PSGALORD,9,PSGAL("N"),2,LN,0)=^PS(53.45,+$GET(PSJSYSP),5,LN,0)
End DoDot:2
+23 SET ^PS(53.45,+$GET(PSJSYSP),5)="AL"
End DoDot:1
+24 QUIT
+25 ; Create new activity log entry
NEWNVAL(PSGALORD,PSGALC,PSGFLD,PSGOLD,PSGOLDAR) ;
+1 ;
+2 ;Where PSGALORD = PSGORD (Required)
+3 ; PSGALC = ACTIVITY CODE FROM #53.3 (Required)
+4 ; PSGFLD = FIELD THAT CHANGED (Free text, optional)
+5 ; PSGOLD = THE FIELDS OLD DATA VALUE (Free text, optional)
+6 ; PSGOLDAR = THE FIELDS OLD DATA VALUE, IF WP FIELD (array, optional)
+7 ;
+8 ;N PSGALORD,PSGALC,PSGFLD,PSGOLD
+9 ;
+10 ; Create 0 node activity log for order if not exists, and get next entry number
+11 SET QQ=$GET(^PS(53.1,+PSGALORD,"A",0))
if QQ=""
SET QQ="^53.1119D"
FOR Q=$PIECE(QQ,"^",3)+1:1
IF '$DATA(^(Q))
SET $PIECE(QQ,"^",3,4)=Q_"^"_Q
SET ^(0)=QQ
SET PSGAL("N")=Q
QUIT
+12 ;Set up data to be held in activity log record
+13 DO NOW^%DTC
SET PSGDT=+$EXTRACT(%,1,12)
+14 ; Use of ... indicates old data field was greater than 170 characters
IF $LENGTH($GET(PSGOLD))>170
SET PSGOLD=$EXTRACT(PSGOLD,1,167)_"..."
+15 SET Q=%_"^"_$SELECT(PSGALC=6010:"AUTO CANCEL",$DATA(DUZ)[0:"UNKNOWN",DUZ]"":DUZ,1:"UNKNOWN")_"^"_PSGALC_"^"_$SELECT($DATA(PSGFLD):PSGFLD,1:"")_"^"_$SELECT($DATA(PSGOLD):PSGOLD,1:"")
+16 ; Create activity log entry
+17 SET ^PS(53.1,+PSGALORD,"A",PSGAL("N"),0)=Q
+18 IF $DATA(PSGOLDAR)&(Q["SPECIAL INSTRUCTIONS"!(Q["OTHER PRINT INFO"))
Begin DoDot:1
+19 IF Q["SPECIAL INSTRUCTIONS"
if '$$DIFFSI^PSJBCMA5(+$GET(DFN),PSGALORD)
QUIT
+20 IF Q["OTHER PRINT INFO"
if '$$DIFFOPI^PSJBCMA5(+$GET(DFN),PSGALORD)
QUIT
+21 NEW LNCNT
SET LNCNT=$ORDER(PSGOLDAR(""),-1)
SET ^PS(53.1,+PSGALORD,"A",PSGAL("N"),1,0)="^53.11195^"_+LNCNT_"^"_+LNCNT
SET ^(1,0)=" "
+22 NEW LN
SET LN=0
FOR
SET LN=$ORDER(PSGOLDAR(LN))
if 'LN
QUIT
SET ^PS(53.1,+PSGALORD,"A",PSGAL("N"),1,LN,0)=PSGOLDAR(LN,0)
End DoDot:1
+23 QUIT
+24 ;
KILLNV ; if user merely reenters same data (tsk, tsk), kill record just written
+1 KILL ^PS(53.1,PSGAL("D0"),"A",PSGAL("N"),0)
IF PSGAL("C")=6000
IF $DATA(PSGALEF)
IF PSGALEF
SET PSGALEF=PSGALEF-1
+2 QUIT
