MCESEDT ;WISC/DCB-ELECTRONIC SIGNATURE PART 1 ; 2/6/03 9:15am
;;2.3;Medicine;**18,37,47**;09/13/1996;Build 12
;
;DE4487 - Call to HMP freshness stream
POST(MCFILE,MCREC) ;Get the info about screen and set-up for edit.
Q:'MCESON
D ENS^%ZISS
N ERROR,HDUZ,HOLD,LOOP,MDAT1,MDAT2,NAME,REC,NEWREC,NEWST,ORG,PROV,RNV,SCRAMBLE,SREC,STATUS,TDATE,TEMP,TEMP1,TY,X1,XDUZ,NCHANGE,LINE,XDATE,DIE,DA,DR,CREAT,SUP,DJDN,CODE,CDUZ,EE,DTOUT,DUOUT,DIRUT,DIROUT
S RNV=+$P($G(^MCAR(697.2,MCARGNUM,0)),U,17)
S ERROR=0,REC=MCREC,NCHANGE=0,(ORG,TEMP)=$G(^MCAR(MCFILE,REC,"ES")),EXIT=0,CODE=$P(TEMP,U,7),PROV=$$ESTONUM1^MCESSCR(CODE),$P(LINE,"_",80)="",MCESPED=TEMP,SUP="" K NEWST
S LOOP=PROV
I $P(TEMP,U,5)="" S XDUZ=1
;I CODE<3,($P(ORG,U,1)="") S $P(TEMP,U,1)=DUZ,$P(ORG,U,1)=DUZ
I PROV<3,($P(ORG,U,1)="") S $P(TEMP,U,1)=DUZ,$P(ORG,U,1)=DUZ
E S XDUZ=4
S XDUZ=+$P(TEMP,U,XDUZ)
I 'MCESSEC D EDD^MCESEDT2 S ^MCAR(MCFILE,MCARGDA,"ES")=TEMP Q
S CREAT=$$GETDATE(15)
I PROV<1!(PROV>7) S PROV=1
I PROV=8 Q
S Y=$P(^MCAR(MCFILE,REC,0),U,1) D DD^%DT
S MDAT1=Y,MDAT2=$P($G(^MCAR(MCFILE,REC,0)),U,2),MDAT2=$P($G(^MCAR(690,+MDAT2,0)),U,1),MDAT2=$P($G(^DPT(+MDAT2,0)),U,1)
S STATUS=$$STATUS(MCFILE,CODE)
I PROV<3 S TDATE=$$GETDATE(3)
E I PROV=3!(PROV=4)!(PROV=6)!(PROV=7) S TDATE=$$GETDATE(9)
E I PROV=5 S TDATE=$$GETDATE(8)
D HEADER
I $P($G(^MCAR(MCFILE,REC,"ES")),U,7)="" D EDITD S ERROR=0 G SKIP
I $D(MCBACK) D EDITSS K MCBACK G SKIP
W !!!
S DIR(0)="Y",DIR("A")=IOINHI_"Do you want to change the release status"_IOINORM,DIR("B")="N" D ^DIR K DIR I $D(DIRUT)!(Y=0) W @IOF N DIE,DA,DR S DIE="^MCAR("_MCFILE_",",DA=REC,DR="1502///NOW" D ^DIE D EXIT Q
SK ;
D HEADER,@("EDIT"_$$NUMTOES^MCESSCR(PROV))
SKIP ;
I EXIT=0 S $P(TEMP,U,7)=SUP_$$NUMTOES^MCESSCR(LOOP) D:LOOP>2 HEADER
D:EXIT=0 @("ED"_$$NUMTOES^MCESSCR(LOOP)_"^MCESEDT2")
D UPDATE:EXIT=0,NOUPDATE:EXIT=1
I '$D(DTOUT) S DIR(0)="E" D ^DIR K DIR
EXIT ;
D KILL^%ZISS W @IOF Q
UPDATE ;
W !!,"Record has been updated with new release information",!!
S ORG=$P(ORG,U,7) K:ORG'="" ^MCAR(MCFILE,"ES",ORG,REC)
S ^MCAR(MCFILE,REC,"ES")=TEMP,^MCAR(MCFILE,"ES",$P(TEMP,U,7),REC)=""
N X S X="HMPEVNT" X ^%ZOSF("TEST") I $T S X=$P($G(^MCAR(MCFILE,REC,0)),U,2),X=$P($G(^MCAR(690,+X,0)),U,1) D CP^HMPEVNT(X,REC_";MCAR("_MCFILE_",") ;DE4487 CPC pass to HMP Freshness stream
Q
NOUPDATE ;
W !!,"Record has not been updated with new release information",!!
;; ***ORIGINAL*** ;; S ^MCAR(MCFILE,REC,"ES")=ORG
; The 'IF $GET' was added to the set line to prevent dangling
; 'ES' nodes when the user supersedes a record, but up-arrows
; out of the edit and sign-off of the new record.
I $G(^MCAR(MCFILE,REC,0))]"" S ^MCAR(MCFILE,REC,"ES")=ORG
D DELSS ; NEW LINE
Q
EDITD ;Draft
EDITPD ;Problem Draft
S DIR("B")=PROV,DIR(0)="S^1:Draft;2:Problem Draft;3:Released On-Line Verified;4:Released Off-line Verified"
S:RNV'=0 DIR(0)=DIR(0)_";5:Released not Verified"
D ASK I EXIT=1,($P($G(^MCAR(MCFILE,REC,"ES")),U,7)="") S TY=1,EXIT=0
Q:EXIT=1
S LOOP=TY
Q
EDITSRV ;
S SUP="S"
EDITRV ;Released On-Line Verified
S DIR("B")=1,DIR(0)="S^1:Released On-Line Verified;2:Supersede" D ASK Q:EXIT=1
S:TY=2 SUP="" S LOOP=$S(TY=1:3,TY=2:8) Q
EDITSROV ;
S SUP="S"
EDITROV ;Released Off-Line Verified
S DIR("B")=2,DIR(0)="S^1:Released On-Line Verified;2:Released Off-Line Verified;3:Supersede" D ASK Q:EXIT=1
S:TY=3 SUP="" S LOOP=$S(TY=1:3,TY=2:4,TY=3:8) Q
EDITRNV ;Released Not Verified
S DIR("B")=3,DIR(0)="S^1:Released On-Line Verified;2:Released Off-line Verified;3:Released not Verified;4:Supersede" D ASK Q:EXIT=1
S LOOP=$S(TY=1:3,TY=2:4,TY=3:5,TY=4:8) Q
EDITSS ;Superseded Change
EDITS S SUP="S",DIR("B")=PROV,DIR(0)="S^1:Released On-Line Verified;2:Released Off-line Verified" D ASK
I EXIT=1 D DELSS Q
S LOOP=$S(TY=1:3,TY=2:4) Q
DELSS ;
Q:'$D(MCESPREV)
W !!,"Since you did not sign the procedure results this report will be"
W !,"deleted and the superseded report will be convert back the way it was."
BACKSS ;
S ^MCAR(MCFILE,MCESPREV,"ES")=MCESTEMP K ^MCAR(MCFILE,"ES","S",MCESPREV)
S ^MCAR(MCFILE,"ES",$P(MCESTEMP,U,7),MCESPREV)="" S DIK="^MCAR("_MCFILE_",",DA=MCARGDA D ^DIK
Q
ASK ;Ask for a status code
S DIR("A")=IOINHI_"Please Select a New Status"_IOINORM,DIR("?")="^D HELP^MCESHLP" D ^DIR S TY=Y I $D(DIRUT)!$D(DUOUT)!$D(DTOUT) S EXIT=1
I Y=DIR("B"),(PROV>2) S EXIT=1,NCHANGE=1
K DIR Q:EXIT=1
S NEWST=Y(0) Q
W @IOF,IODHLT," * * * Release Control * * *",!,IODHLB," * * * Release Control * * *"
W !,LINE
W:CREAT'[1700 !!,?4,IOINHI,"Created on: ",IOINORM,CREAT
W !!,IOINHI,?14,"DATE: ",IOINORM,MDAT1,!,?16,MDAT2,!!,IOINHI,"Current Status: ",IOINORM,IOBON,STATUS,IOBOFF
W:TDATE'="" IOINHI," as of ",IOINORM,TDATE
S NAME=$$DECODE^MCESPRT(ORG,CODE,MCFILE,MCARGDA)
W !,IOINHI,?16,"by: ",IOINORM,NAME
I PROV=4 D PROVID
I PROV=7!(PROV=8) S Y=$P(TEMP,U,14) D DD^%DT W !!,"This record supersedes record created on ",IOUON,Y,IOUOFF,"."
W:$D(NEWST) !!,IOINHI,?8,"New status: ",IOINORM,NEWST
W !,LINE Q
PROVID ;
W !,IOINHI,?15,"for: ",IOINORM
S HDUZ=+$P(TEMP,U,4)
I '$D(^VA(200,HDUZ,0)) W "unknown"
E W $P(^VA(200,HDUZ,0),U,1)
K HDUZ Q
GETDATE(EE) ;
N Y S Y=$P(TEMP,U,EE) D DD^%DT Q Y
STATUS(FILE,PROV) ;
N Y,C S Y=PROV,C=$P(^DD(FILE,1506,0),U,2) D Y^DIQ
S:Y="" Y="DRAFT"
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCESEDT 5383 printed Oct 16, 2024@18:15:42 Page 2
MCESEDT ;WISC/DCB-ELECTRONIC SIGNATURE PART 1 ; 2/6/03 9:15am
+1 ;;2.3;Medicine;**18,37,47**;09/13/1996;Build 12
+2 ;
+3 ;DE4487 - Call to HMP freshness stream
POST(MCFILE,MCREC) ;Get the info about screen and set-up for edit.
+1 if 'MCESON
QUIT
+2 DO ENS^%ZISS
+3 NEW ERROR,HDUZ,HOLD,LOOP,MDAT1,MDAT2,NAME,REC,NEWREC,NEWST,ORG,PROV,RNV,SCRAMBLE,SREC,STATUS,TDATE,TEMP,TEMP1,TY,X1,XDUZ,NCHANGE,LINE,XDATE,DIE,DA,DR,CREAT,SUP,DJDN,CODE,CDUZ,EE,DTOUT,DUOUT,DIRUT,DIROUT
+4 SET RNV=+$PIECE($GET(^MCAR(697.2,MCARGNUM,0)),U,17)
+5 SET ERROR=0
SET REC=MCREC
SET NCHANGE=0
SET (ORG,TEMP)=$GET(^MCAR(MCFILE,REC,"ES"))
SET EXIT=0
SET CODE=$PIECE(TEMP,U,7)
SET PROV=$$ESTONUM1^MCESSCR(CODE)
SET $PIECE(LINE,"_",80)=""
SET MCESPED=TEMP
SET SUP=""
KILL NEWST
+6 SET LOOP=PROV
+7 IF $PIECE(TEMP,U,5)=""
SET XDUZ=1
+8 ;I CODE<3,($P(ORG,U,1)="") S $P(TEMP,U,1)=DUZ,$P(ORG,U,1)=DUZ
+9 IF PROV<3
IF ($PIECE(ORG,U,1)="")
SET $PIECE(TEMP,U,1)=DUZ
SET $PIECE(ORG,U,1)=DUZ
+10 IF '$TEST
SET XDUZ=4
+11 SET XDUZ=+$PIECE(TEMP,U,XDUZ)
+12 IF 'MCESSEC
DO EDD^MCESEDT2
SET ^MCAR(MCFILE,MCARGDA,"ES")=TEMP
QUIT
+13 SET CREAT=$$GETDATE(15)
+14 IF PROV<1!(PROV>7)
SET PROV=1
+15 IF PROV=8
QUIT
+16 SET Y=$PIECE(^MCAR(MCFILE,REC,0),U,1)
DO DD^%DT
+17 SET MDAT1=Y
SET MDAT2=$PIECE($GET(^MCAR(MCFILE,REC,0)),U,2)
SET MDAT2=$PIECE($GET(^MCAR(690,+MDAT2,0)),U,1)
SET MDAT2=$PIECE($GET(^DPT(+MDAT2,0)),U,1)
+18 SET STATUS=$$STATUS(MCFILE,CODE)
+19 IF PROV<3
SET TDATE=$$GETDATE(3)
+20 IF '$TEST
IF PROV=3!(PROV=4)!(PROV=6)!(PROV=7)
SET TDATE=$$GETDATE(9)
+21 IF '$TEST
IF PROV=5
SET TDATE=$$GETDATE(8)
+22 DO HEADER
+23 IF $PIECE($GET(^MCAR(MCFILE,REC,"ES")),U,7)=""
DO EDITD
SET ERROR=0
GOTO SKIP
+24 IF $DATA(MCBACK)
DO EDITSS
KILL MCBACK
GOTO SKIP
+25 WRITE !!!
+26 SET DIR(0)="Y"
SET DIR("A")=IOINHI_"Do you want to change the release status"_IOINORM
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)!(Y=0)
WRITE @IOF
NEW DIE,DA,DR
SET DIE="^MCAR("_MCFILE_","
SET DA=REC
SET DR="1502///NOW"
DO ^DIE
DO EXIT
QUIT
SK ;
+1 DO HEADER
DO @("EDIT"_$$NUMTOES^MCESSCR(PROV))
SKIP ;
+1 IF EXIT=0
SET $PIECE(TEMP,U,7)=SUP_$$NUMTOES^MCESSCR(LOOP)
if LOOP>2
DO HEADER
+2 if EXIT=0
DO @("ED"_$$NUMTOES^MCESSCR(LOOP)_"^MCESEDT2")
+3 if EXIT=0
DO UPDATE
if EXIT=1
DO NOUPDATE
+4 IF '$DATA(DTOUT)
SET DIR(0)="E"
DO ^DIR
KILL DIR
EXIT ;
+1 DO KILL^%ZISS
WRITE @IOF
QUIT
UPDATE ;
+1 WRITE !!,"Record has been updated with new release information",!!
+2 SET ORG=$PIECE(ORG,U,7)
if ORG'=""
KILL ^MCAR(MCFILE,"ES",ORG,REC)
+3 SET ^MCAR(MCFILE,REC,"ES")=TEMP
SET ^MCAR(MCFILE,"ES",$PIECE(TEMP,U,7),REC)=""
+4 ;DE4487 CPC pass to HMP Freshness stream
NEW X
SET X="HMPEVNT"
XECUTE ^%ZOSF("TEST")
IF $TEST
SET X=$PIECE($GET(^MCAR(MCFILE,REC,0)),U,2)
SET X=$PIECE($GET(^MCAR(690,+X,0)),U,1)
DO CP^HMPEVNT(X,REC_";MCAR("_MCFILE_",")
+5 QUIT
NOUPDATE ;
+1 WRITE !!,"Record has not been updated with new release information",!!
+2 ;; ***ORIGINAL*** ;; S ^MCAR(MCFILE,REC,"ES")=ORG
+3 ; The 'IF $GET' was added to the set line to prevent dangling
+4 ; 'ES' nodes when the user supersedes a record, but up-arrows
+5 ; out of the edit and sign-off of the new record.
+6 IF $GET(^MCAR(MCFILE,REC,0))]""
SET ^MCAR(MCFILE,REC,"ES")=ORG
+7 ; NEW LINE
DO DELSS
+8 QUIT
EDITD ;Draft
EDITPD ;Problem Draft
+1 SET DIR("B")=PROV
SET DIR(0)="S^1:Draft;2:Problem Draft;3:Released On-Line Verified;4:Released Off-line Verified"
+2 if RNV'=0
SET DIR(0)=DIR(0)_";5:Released not Verified"
+3 DO ASK
IF EXIT=1
IF ($PIECE($GET(^MCAR(MCFILE,REC,"ES")),U,7)="")
SET TY=1
SET EXIT=0
+4 if EXIT=1
QUIT
+5 SET LOOP=TY
+6 QUIT
EDITSRV ;
+1 SET SUP="S"
EDITRV ;Released On-Line Verified
+1 SET DIR("B")=1
SET DIR(0)="S^1:Released On-Line Verified;2:Supersede"
DO ASK
if EXIT=1
QUIT
+2 if TY=2
SET SUP=""
SET LOOP=$SELECT(TY=1:3,TY=2:8)
QUIT
EDITSROV ;
+1 SET SUP="S"
EDITROV ;Released Off-Line Verified
+1 SET DIR("B")=2
SET DIR(0)="S^1:Released On-Line Verified;2:Released Off-Line Verified;3:Supersede"
DO ASK
if EXIT=1
QUIT
+2 if TY=3
SET SUP=""
SET LOOP=$SELECT(TY=1:3,TY=2:4,TY=3:8)
QUIT
EDITRNV ;Released Not Verified
+1 SET DIR("B")=3
SET DIR(0)="S^1:Released On-Line Verified;2:Released Off-line Verified;3:Released not Verified;4:Supersede"
DO ASK
if EXIT=1
QUIT
+2 SET LOOP=$SELECT(TY=1:3,TY=2:4,TY=3:5,TY=4:8)
QUIT
EDITSS ;Superseded Change
EDITS SET SUP="S"
SET DIR("B")=PROV
SET DIR(0)="S^1:Released On-Line Verified;2:Released Off-line Verified"
DO ASK
+1 IF EXIT=1
DO DELSS
QUIT
+2 SET LOOP=$SELECT(TY=1:3,TY=2:4)
QUIT
DELSS ;
+1 if '$DATA(MCESPREV)
QUIT
+2 WRITE !!,"Since you did not sign the procedure results this report will be"
+3 WRITE !,"deleted and the superseded report will be convert back the way it was."
BACKSS ;
+1 SET ^MCAR(MCFILE,MCESPREV,"ES")=MCESTEMP
KILL ^MCAR(MCFILE,"ES","S",MCESPREV)
+2 SET ^MCAR(MCFILE,"ES",$PIECE(MCESTEMP,U,7),MCESPREV)=""
SET DIK="^MCAR("_MCFILE_","
SET DA=MCARGDA
DO ^DIK
+3 QUIT
ASK ;Ask for a status code
+1 SET DIR("A")=IOINHI_"Please Select a New Status"_IOINORM
SET DIR("?")="^D HELP^MCESHLP"
DO ^DIR
SET TY=Y
IF $DATA(DIRUT)!$DATA(DUOUT)!$DATA(DTOUT)
SET EXIT=1
+2 IF Y=DIR("B")
IF (PROV>2)
SET EXIT=1
SET NCHANGE=1
+3 KILL DIR
if EXIT=1
QUIT
+4 SET NEWST=Y(0)
QUIT
+1 WRITE @IOF,IODHLT," * * * Release Control * * *",!,IODHLB," * * * Release Control * * *"
+2 WRITE !,LINE
+3 if CREAT'[1700
WRITE !!,?4,IOINHI,"Created on: ",IOINORM,CREAT
+4 WRITE !!,IOINHI,?14,"DATE: ",IOINORM,MDAT1,!,?16,MDAT2,!!,IOINHI,"Current Status: ",IOINORM,IOBON,STATUS,IOBOFF
+5 if TDATE'=""
WRITE IOINHI," as of ",IOINORM,TDATE
+6 SET NAME=$$DECODE^MCESPRT(ORG,CODE,MCFILE,MCARGDA)
+7 WRITE !,IOINHI,?16,"by: ",IOINORM,NAME
+8 IF PROV=4
DO PROVID
+9 IF PROV=7!(PROV=8)
SET Y=$PIECE(TEMP,U,14)
DO DD^%DT
WRITE !!,"This record supersedes record created on ",IOUON,Y,IOUOFF,"."
+10 if $DATA(NEWST)
WRITE !!,IOINHI,?8,"New status: ",IOINORM,NEWST
+11 WRITE !,LINE
QUIT
PROVID ;
+1 WRITE !,IOINHI,?15,"for: ",IOINORM
+2 SET HDUZ=+$PIECE(TEMP,U,4)
+3 IF '$DATA(^VA(200,HDUZ,0))
WRITE "unknown"
+4 IF '$TEST
WRITE $PIECE(^VA(200,HDUZ,0),U,1)
+5 KILL HDUZ
QUIT
GETDATE(EE) ;
+1 NEW Y
SET Y=$PIECE(TEMP,U,EE)
DO DD^%DT
QUIT Y
STATUS(FILE,PROV) ;
+1 NEW Y,C
SET Y=PROV
SET C=$PIECE(^DD(FILE,1506,0),U,2)
DO Y^DIQ
+2 if Y=""
SET Y="DRAFT"
+3 QUIT Y
