ACRFCERT ;IHS/OIRM/DSD/THL,AEF - DOCUMENT CERTIFICATION MANAGEMENT UTILITY; [ 09/23/2005 9:44 AM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**19**;NOV 05, 2001
;;ROUTINE USED TO CREATE, EDIT AND MANAGE DOCUMENT CERTIFICATION
;;STATEMENTS
STATE ;EP;TO ADD NEW CERTIFICATION STATEMENTS
F D CERT Q:$D(ACRQUIT)!$D(ACROUT)
K ACRQUIT
Q
CERT ;DISPLAY AND EDIT CERTIFICATION STATEMENTS
W @IOF
W !!?20,"DOCUMENT CERTIFICATION STATEMENTS"
W !!
S DIC="^ACRAPVC("
S DIC(0)="AEMLQZ"
S DIC("A")="CERT. STATEMENT.....: "
D DIC^ACRFDIC
I +Y<1 S ACRQUIT="" Q
S DA=+Y,DIE="^ACRAPVC(",DR="[ACR APPROVAL CERTIFICATION]"
D DIE^ACRFDIC
Q
DOCCERT ;EP;UTILITY TO SELECT CERTIFICATION STATEMENTS TO ADD TO DOCUMENT
I $D(^ACRDOCAC("C",ACRDOCDA)) D DELCERT
W !!?3,"Select CERTIFICATIONS for ",$P(^ACRAPVT(ACRAPVT,0),U)
W !
N ACR,ACRCDA
S (ACR,ACRCDA)=0
F S ACRCDA=$O(^ACRAPVC("AC",ACRAPVT,ACRTXTYP,ACRCDA)) Q:'ACRCDA D
.Q:'$D(^ACRAPVC(ACRCDA,0))
.S ACR=ACR+1
.S ACR(ACR)=ACRCDA
.W !?10,ACR
.W ?15,$P(^ACRAPVC(ACRCDA,0),U)
S DIR(0)="LO^1:"_ACR
S DIR("A")="Which One(s)"
S DIR("?")="Indicate the number(s) of applicable Certifying Statements"
W !
D DIR^ACRFDIC
I $D(ACRQUIT)!$D(ACROUT) Q
N ACRI,ACRX
S ACRY=Y
F ACRI=1:1 S ACRX=$P(ACRY,",",ACRI) Q:ACRX="" D
.S (X,ACRCS)=ACR(ACRX)
.S DIC="^ACRDOCAC("
.S DIC(0)="L"
.S DIC("DR")=".02////"_ACRDOCDA_";.03////"_ACRAPDA
.I '$D(^ACRDOCAC("AC",ACRDOCDA,X)) D
..D FILE^ACRFDIC
..S ACRCSDA=+Y
..D XY
.I $D(^ACRDOCAC("AC",ACRDOCDA,ACRCS)) S ACRCSDA=$O(^(ACRCS,0)) D
..I ACRCSDA D
...W !!,"You have added the ",$P(^ACRAPVC(ACRCS,0),U)
...W " statement to this document."
...S DIR(0)="YO"
...S DIR("A")="Do you want to edit the statement"
...S DIR("B")="NO"
...D DIR^ACRFDIC
...I Y=1 D
....S DA=ACRCSDA,DIE="^ACRDOCAC(",DR=1
....W !
....D DIE^ACRFDIC
Q
CAPPEND ;EP;CERTIFICATION APPENDED TO DOCUMENT AND EDITED
Q:'$D(ACRDOCDA)
I '$D(^ACRDOCAC("C",ACRDOCDA)) W !!,"NO CERTIFICATIONS APPENDED."
DELCERT N ACR,ACRI
S ACR=0
F ACRI=1:1 S ACR=$O(^ACRDOCAC("C",ACRDOCDA,ACR)) Q:'ACR D
.I ACRI=1 D
..W !!?10,"CERTIFICATIONS APPENDED:"
..W !?10,"------------------------"
.I $D(^ACRDOCAC(ACR,0)) S ACRCDA=+^(0) D:ACRCDA
..W !?10,ACRI
..W ?15,$P(^ACRAPVC(ACRCDA,0),U)
..S DIR(0)="YO"
..S DIR("A")=" Read Certification NO. "_ACRI_" "
..S DIR("B")="NO"
..D DIR^ACRFDIC
..I Y=1 D
...S D0=ACR
...N DXS,DIP,DC,DN
...W @IOF
...W !
...D ^ACRCS
...D PAUSE^ACRFWARN
...W !
..I '$D(ACRREV) D
...S DIR(0)="YO"
...S DIR("A")=" Delete Certification NO. "_ACRI_" "
...S DIR("B")="NO"
...D DIR^ACRFDIC
...I Y=1 D
....K ^ACRDOCAC("C",ACRDOCDA,ACR),^ACRDOCAC("AC",ACRDOCDA,ACRCDA,ACR)
....W !!,"Certification NO. "_ACRI_" deleted."
Q
XY ;%XY USED TO SET CERTIFICATION STATEMENT FOR DOCUMENT EQUAL TO
;STANDARD CERTIFICATION STATEMENT
S %X="^ACRAPVC("_ACR(ACRX)_",1,"
S %Y="^ACRDOCAC("_ACRCSDA_",1,"
D %XY^%RCR
K %X,%Y
Q
PCERT ;EP;TO PRINT CERTIFICATION STATEMENTS ATTACHED TO A DOCUMENT
Q:$D(ACROUT)
W:$O(^ACRDOCAC("C",ACRDOCDA,0)) @IOF
N ACR,D0
S ACR=0
F S ACR=$O(^ACRDOCAC("C",ACRDOCDA,ACR)) Q:'ACR D
.N DXS,DIP,DC,DN
.S D0=ACR
.I $E($G(IOST),1,2)="C-" D Q:'$D(ACRSCREN)
..N ACRFILE,ACRIEN,ACRFIELD,ACRTITLE
..S ACRFILE=9002197.1
..S ACRIEN=ACR
..S ACRFIELD=1
..S ACRTITLE="ARMS CERTIFICATION STATEMENT"
..D WP^ACRFDIC
.K ACRSCREN
.D ^ACRCS
.I ACRREFX=116,$D(^ACRAPVS("AB",ACRDOCDA)) D
..S ACRX=$P(^ACRDOCAC(ACR,0),U,3)
..I ACRX,$D(^ACRAPVS(ACRX,0)) S ACRAPVT=$P(^(0),U,2) I ACRAPVT D
...I $D(^ACRAPVT(ACRAPVT,0)),$D(^ACRAPVS("AB",ACRDOCDA)) D SIG
.I $E($G(IOST),1,2)["C-" D PAUSE^ACRFWARN
.W @IOF
Q
SIG ;EP;TO PRINT THE CERTIFYING SIGNATURE ON THE CERTIFICATION STATEMENT
;OR BOILER PLATE STATEMENT.
N X,Y
S X=0
F S X=$O(^ACRAPVS("AB",ACRDOCDA,X)) Q:'X I $D(^ACRAPVS(X,0)),$D(^("DT")),$P(^("DT"),U)="A",$P(^(0),U,3)=ACRAPVT S X=^("DT") D Q
.S Y=$P(X,U,4)
.S X=$S($P(X,U,2)=$P(X,U,6):$P(X,U,2),1:$P(X,U,6))
.Q:'$D(^VA(200,X,0))
.;S X=$P(^VA(200,X,0),U) ;ACR*2.1*19.02 IM16848
.S X=$$NAME2^ACRFUTL1(X) ;ACR*2.1*19.02 IM16848
.S X=$P($P(X,",",2)," ")_" "_$P(X,U)
.W !!,X
.W ?$X+4,"(ELECTRONIC SIGNATURE)"
.X ^DD("DD")
.W ?60,Y
Q
ACRFCERT ;IHS/OIRM/DSD/THL,AEF - DOCUMENT CERTIFICATION MANAGEMENT UTILITY; [ 09/23/2005 9:44 AM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**19**;NOV 05, 2001
+2 ;;ROUTINE USED TO CREATE, EDIT AND MANAGE DOCUMENT CERTIFICATION
+3 ;;STATEMENTS
STATE ;EP;TO ADD NEW CERTIFICATION STATEMENTS
+1 FOR
DO CERT
IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+2 KILL ACRQUIT
+3 QUIT
CERT ;DISPLAY AND EDIT CERTIFICATION STATEMENTS
+1 WRITE @IOF
+2 WRITE !!?20,"DOCUMENT CERTIFICATION STATEMENTS"
+3 WRITE !!
+4 SET DIC="^ACRAPVC("
+5 SET DIC(0)="AEMLQZ"
+6 SET DIC("A")="CERT. STATEMENT.....: "
+7 DO DIC^ACRFDIC
+8 IF +Y<1
SET ACRQUIT=""
QUIT
+9 SET DA=+Y
SET DIE="^ACRAPVC("
SET DR="[ACR APPROVAL CERTIFICATION]"
+10 DO DIE^ACRFDIC
+11 QUIT
DOCCERT ;EP;UTILITY TO SELECT CERTIFICATION STATEMENTS TO ADD TO DOCUMENT
+1 IF $DATA(^ACRDOCAC("C",ACRDOCDA))
DO DELCERT
+2 WRITE !!?3,"Select CERTIFICATIONS for ",$PIECE(^ACRAPVT(ACRAPVT,0),U)
+3 WRITE !
+4 NEW ACR,ACRCDA
+5 SET (ACR,ACRCDA)=0
+6 FOR
SET ACRCDA=$ORDER(^ACRAPVC("AC",ACRAPVT,ACRTXTYP,ACRCDA))
IF 'ACRCDA
QUIT
Begin DoDot:1
+7 IF '$DATA(^ACRAPVC(ACRCDA,0))
QUIT
+8 SET ACR=ACR+1
+9 SET ACR(ACR)=ACRCDA
+10 WRITE !?10,ACR
+11 WRITE ?15,$PIECE(^ACRAPVC(ACRCDA,0),U)
End DoDot:1
+12 SET DIR(0)="LO^1:"_ACR
+13 SET DIR("A")="Which One(s)"
+14 SET DIR("?")="Indicate the number(s) of applicable Certifying Statements"
+15 WRITE !
+16 DO DIR^ACRFDIC
+17 IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+18 NEW ACRI,ACRX
+19 SET ACRY=Y
+20 FOR ACRI=1:1
SET ACRX=$PIECE(ACRY,",",ACRI)
IF ACRX=""
QUIT
Begin DoDot:1
+21 SET (X,ACRCS)=ACR(ACRX)
+22 SET DIC="^ACRDOCAC("
+23 SET DIC(0)="L"
+24 SET DIC("DR")=".02////"_ACRDOCDA_";.03////"_ACRAPDA
+25 IF '$DATA(^ACRDOCAC("AC",ACRDOCDA,X))
Begin DoDot:2
+26 DO FILE^ACRFDIC
+27 SET ACRCSDA=+Y
+28 DO XY
End DoDot:2
+29 IF $DATA(^ACRDOCAC("AC",ACRDOCDA,ACRCS))
SET ACRCSDA=$ORDER(^(ACRCS,0))
Begin DoDot:2
+30 IF ACRCSDA
Begin DoDot:3
+31 WRITE !!,"You have added the ",$PIECE(^ACRAPVC(ACRCS,0),U)
+32 WRITE " statement to this document."
+33 SET DIR(0)="YO"
+34 SET DIR("A")="Do you want to edit the statement"
+35 SET DIR("B")="NO"
+36 DO DIR^ACRFDIC
+37 IF Y=1
Begin DoDot:4
+38 SET DA=ACRCSDA
SET DIE="^ACRDOCAC("
SET DR=1
+39 WRITE !
+40 DO DIE^ACRFDIC
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+41 QUIT
CAPPEND ;EP;CERTIFICATION APPENDED TO DOCUMENT AND EDITED
+1 IF '$DATA(ACRDOCDA)
QUIT
+2 IF '$DATA(^ACRDOCAC("C",ACRDOCDA))
WRITE !!,"NO CERTIFICATIONS APPENDED."
DELCERT NEW ACR,ACRI
+1 SET ACR=0
+2 FOR ACRI=1:1
SET ACR=$ORDER(^ACRDOCAC("C",ACRDOCDA,ACR))
IF 'ACR
QUIT
Begin DoDot:1
+3 IF ACRI=1
Begin DoDot:2
+4 WRITE !!?10,"CERTIFICATIONS APPENDED:"
+5 WRITE !?10,"------------------------"
End DoDot:2
+6 IF $DATA(^ACRDOCAC(ACR,0))
SET ACRCDA=+^(0)
IF ACRCDA
Begin DoDot:2
+7 WRITE !?10,ACRI
+8 WRITE ?15,$PIECE(^ACRAPVC(ACRCDA,0),U)
+9 SET DIR(0)="YO"
+10 SET DIR("A")=" Read Certification NO. "_ACRI_" "
+11 SET DIR("B")="NO"
+12 DO DIR^ACRFDIC
+13 IF Y=1
Begin DoDot:3
+14 SET D0=ACR
+15 NEW DXS,DIP,DC,DN
+16 WRITE @IOF
+17 WRITE !
+18 DO ^ACRCS
+19 DO PAUSE^ACRFWARN
+20 WRITE !
End DoDot:3
+21 IF '$DATA(ACRREV)
Begin DoDot:3
+22 SET DIR(0)="YO"
+23 SET DIR("A")=" Delete Certification NO. "_ACRI_" "
+24 SET DIR("B")="NO"
+25 DO DIR^ACRFDIC
+26 IF Y=1
Begin DoDot:4
+27 KILL ^ACRDOCAC("C",ACRDOCDA,ACR),^ACRDOCAC("AC",ACRDOCDA,ACRCDA,ACR)
+28 WRITE !!,"Certification NO. "_ACRI_" deleted."
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+29 QUIT
XY ;%XY USED TO SET CERTIFICATION STATEMENT FOR DOCUMENT EQUAL TO
+1 ;STANDARD CERTIFICATION STATEMENT
+2 SET %X="^ACRAPVC("_ACR(ACRX)_",1,"
+3 SET %Y="^ACRDOCAC("_ACRCSDA_",1,"
+4 DO %XY^%RCR
+5 KILL %X,%Y
+6 QUIT
PCERT ;EP;TO PRINT CERTIFICATION STATEMENTS ATTACHED TO A DOCUMENT
+1 IF $DATA(ACROUT)
QUIT
+2 IF $ORDER(^ACRDOCAC("C",ACRDOCDA,0))
WRITE @IOF
+3 NEW ACR,D0
+4 SET ACR=0
+5 FOR
SET ACR=$ORDER(^ACRDOCAC("C",ACRDOCDA,ACR))
IF 'ACR
QUIT
Begin DoDot:1
+6 NEW DXS,DIP,DC,DN
+7 SET D0=ACR
+8 IF $EXTRACT($GET(IOST),1,2)="C-"
Begin DoDot:2
+9 NEW ACRFILE,ACRIEN,ACRFIELD,ACRTITLE
+10 SET ACRFILE=9002197.1
+11 SET ACRIEN=ACR
+12 SET ACRFIELD=1
+13 SET ACRTITLE="ARMS CERTIFICATION STATEMENT"
+14 DO WP^ACRFDIC
End DoDot:2
IF '$DATA(ACRSCREN)
QUIT
+15 KILL ACRSCREN
+16 DO ^ACRCS
+17 IF ACRREFX=116
IF $DATA(^ACRAPVS("AB",ACRDOCDA))
Begin DoDot:2
+18 SET ACRX=$PIECE(^ACRDOCAC(ACR,0),U,3)
+19 IF ACRX
IF $DATA(^ACRAPVS(ACRX,0))
SET ACRAPVT=$PIECE(^(0),U,2)
IF ACRAPVT
Begin DoDot:3
+20 IF $DATA(^ACRAPVT(ACRAPVT,0))
IF $DATA(^ACRAPVS("AB",ACRDOCDA))
DO SIG
End DoDot:3
End DoDot:2
+21 IF $EXTRACT($GET(IOST),1,2)["C-"
DO PAUSE^ACRFWARN
+22 WRITE @IOF
End DoDot:1
+23 QUIT
SIG ;EP;TO PRINT THE CERTIFYING SIGNATURE ON THE CERTIFICATION STATEMENT
+1 ;OR BOILER PLATE STATEMENT.
+2 NEW X,Y
+3 SET X=0
+4 FOR
SET X=$ORDER(^ACRAPVS("AB",ACRDOCDA,X))
IF 'X
QUIT
IF $DATA(^ACRAPVS(X,0))
IF $DATA(^("DT"))
IF $PIECE(^("DT"),U)="A"
IF $PIECE(^(0),U,3)=ACRAPVT
SET X=^("DT")
Begin DoDot:1
+5 SET Y=$PIECE(X,U,4)
+6 SET X=$SELECT($PIECE(X,U,2)=$PIECE(X,U,6):$PIECE(X,U,2),1:$PIECE(X,U,6))
+7 IF '$DATA(^VA(200,X,0))
QUIT
+8 ;S X=$P(^VA(200,X,0),U) ;ACR*2.1*19.02 IM16848
+9 ;ACR*2.1*19.02 IM16848
SET X=$$NAME2^ACRFUTL1(X)
+10 SET X=$PIECE($PIECE(X,",",2)," ")_" "_$PIECE(X,U)
+11 WRITE !!,X
+12 WRITE ?$X+4,"(ELECTRONIC SIGNATURE)"
+13 XECUTE ^DD("DD")
+14 WRITE ?60,Y
End DoDot:1
QUIT
+15 QUIT
