- 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
