- DGPTMSG1 ;ALB/AS - Format PTF Messages ; 7 NOV 89 @ 0800
- ;;5.3;Registration;**61**;Aug 13, 1993
- ;
- DICN ; -- add message entry
- I $P(^DG(43,1,0),"^",40)=0 S Y=-1 G DICNQ
- DICN1 S DINUM=$P(^DGM(0),"^",3)
- L S DINUM=DINUM+1 L ^DGM(DINUM):1 I '$T!($D(^DGM(DINUM))) L G L
- S DIC="^DGM(",DIC("DR")="[DG PTF ADD MESSAGE]",DIC(0)="L",X=DINUM K DD,DO D FILE^DICN
- DICNQ K DINUM,DIC Q
- ;
- DS ;called for Deleted Discharge Date Message
- S Y=$S($D(DGPMP):$E(+DGPMP,1,12),1:"") X ^DD("DD") S DGMSG="A discharge date"_$S($D(DGPMP):" of "_Y,1:" ")_" was deleted by "_$P(^VA(200,+DUZ,0),U)_". Please verify PTF files."
- D MSG Q
- ;
- MSG ; -- generic call to add DGMSG to PTF MESSAGE file
- ; input: DFN and DGMSG
- ;
- D DICN
- I +Y>0 S DA=+Y,DGADMTY=$P(DGPMAN,"^",4) D QU
- K DGMSG,DGMSG1 Q
- ;
- MOV ; -- called for Patient Admitted Message, Diagnosis Change Message
- Q:'$D(DGPMCA)!('$D(DGPMDA))
- K DGMSG D DICN G MOVQ:Y<0 S DA=+Y
- F X=0:0 S X=$O(^DGPM(DGPMDA,"DX",X)) Q:X'>0 S ^DGM(DA,"M",X,0)=^DGPM(DGPMDA,"DX",X,0)
- S ^DGM(DA,"M",0)=$S($D(^DGPM(DGPMDA,"DX",0)):^(0),1:"")
- S DGADMTY=$P(^DGPM(DGPMCA,0),"^",4) D QU
- MOVQ Q
- ;
- QU ; -- que message to print
- G QUQ:'$P(^DG(43,1,0),"^",31)
- S DGADMTY=$S($D(DGADMTY):DGADMTY,1:""),DGMISD=""
- I $D(^DIC(42,+$P(DGPMAN,"^",6),0)) S DGZ=$P(^(0),"^",11),DGMISD=$S($D(^DG(40.8,+DGZ,"DEV")):$P(^("DEV"),"^",4),1:"")
- I DGMISD="" S DGMISD=$P(^DG(43,1,0),"^",19) G QUQ:DGMISD=""
- S DGPGM="PR^DGPTMSG",DGVAR="DGADMTY^DA",ZTIO=DGMISD,DGUTQND=""
- D Q1^DGUTQ I '$G(DGQUIET) W !!,"**** "_$S($D(DGMSG1):DGMSG1_" ",1:"")_"Message Transmitted to MIS ****",!
- QUQ K DGMSG1,DGMSG,DGADMTY,DGPGM,DGUTQND,DGVAR,DIC,DGZ,X,Y,DA,DGMISD Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTMSG1 1674 printed Jan 18, 2025@03:53:36 Page 2
- DGPTMSG1 ;ALB/AS - Format PTF Messages ; 7 NOV 89 @ 0800
- +1 ;;5.3;Registration;**61**;Aug 13, 1993
- +2 ;
- DICN ; -- add message entry
- +1 IF $PIECE(^DG(43,1,0),"^",40)=0
- SET Y=-1
- GOTO DICNQ
- DICN1 SET DINUM=$PIECE(^DGM(0),"^",3)
- L SET DINUM=DINUM+1
- LOCK ^DGM(DINUM):1
- IF '$TEST!($DATA(^DGM(DINUM)))
- LOCK
- GOTO L
- +1 SET DIC="^DGM("
- SET DIC("DR")="[DG PTF ADD MESSAGE]"
- SET DIC(0)="L"
- SET X=DINUM
- KILL DD,DO
- DO FILE^DICN
- DICNQ KILL DINUM,DIC
- QUIT
- +1 ;
- DS ;called for Deleted Discharge Date Message
- +1 SET Y=$SELECT($DATA(DGPMP):$EXTRACT(+DGPMP,1,12),1:"")
- XECUTE ^DD("DD")
- SET DGMSG="A discharge date"_$SELECT($DATA(DGPMP):" of "_Y,1:" ")_" was deleted by "_$PIECE(^VA(200,+DUZ,0),U)_". Please verify PTF files."
- +2 DO MSG
- QUIT
- +3 ;
- MSG ; -- generic call to add DGMSG to PTF MESSAGE file
- +1 ; input: DFN and DGMSG
- +2 ;
- +3 DO DICN
- +4 IF +Y>0
- SET DA=+Y
- SET DGADMTY=$PIECE(DGPMAN,"^",4)
- DO QU
- +5 KILL DGMSG,DGMSG1
- QUIT
- +6 ;
- MOV ; -- called for Patient Admitted Message, Diagnosis Change Message
- +1 if '$DATA(DGPMCA)!('$DATA(DGPMDA))
- QUIT
- +2 KILL DGMSG
- DO DICN
- if Y<0
- GOTO MOVQ
- SET DA=+Y
- +3 FOR X=0:0
- SET X=$ORDER(^DGPM(DGPMDA,"DX",X))
- if X'>0
- QUIT
- SET ^DGM(DA,"M",X,0)=^DGPM(DGPMDA,"DX",X,0)
- +4 SET ^DGM(DA,"M",0)=$SELECT($DATA(^DGPM(DGPMDA,"DX",0)):^(0),1:"")
- +5 SET DGADMTY=$PIECE(^DGPM(DGPMCA,0),"^",4)
- DO QU
- MOVQ QUIT
- +1 ;
- QU ; -- que message to print
- +1 if '$PIECE(^DG(43,1,0),"^",31)
- GOTO QUQ
- +2 SET DGADMTY=$SELECT($DATA(DGADMTY):DGADMTY,1:"")
- SET DGMISD=""
- +3 IF $DATA(^DIC(42,+$PIECE(DGPMAN,"^",6),0))
- SET DGZ=$PIECE(^(0),"^",11)
- SET DGMISD=$SELECT($DATA(^DG(40.8,+DGZ,"DEV")):$PIECE(^("DEV"),"^",4),1:"")
- +4 IF DGMISD=""
- SET DGMISD=$PIECE(^DG(43,1,0),"^",19)
- if DGMISD=""
- GOTO QUQ
- +5 SET DGPGM="PR^DGPTMSG"
- SET DGVAR="DGADMTY^DA"
- SET ZTIO=DGMISD
- SET DGUTQND=""
- +6 DO Q1^DGUTQ
- IF '$GET(DGQUIET)
- WRITE !!,"**** "_$SELECT($DATA(DGMSG1):DGMSG1_" ",1:"")_"Message Transmitted to MIS ****",!
- QUQ KILL DGMSG1,DGMSG,DGADMTY,DGPGM,DGUTQND,DGVAR,DIC,DGZ,X,Y,DA,DGMISD
- QUIT