- ACRFRESP ;IHS/OIRM/DSD/THL,AEF - ADD/EDIT APPROVAL RESPONSE; [ 09/23/2005 9:44 AM ]
- ;;2.1;ADMIN RESOURCE MGT SYSTEM;**19**;NOV 05, 2001
- ;;UTILITY ROUTINE TO ADD/EDIT APPROVAL RESPONSE
- RESP ;EP;TO PROCESS RESPONSE TO REQUEST FOR CHANGE OR CLARIFICATION OF A
- ;REQUEST
- N ACRDOCDT,ACRRESP,ACRINDV,ACRAPDA
- D RESP1
- Q
- RESP1 S ACRDOCDT=$G(^ACRDOC(ACRDOCDA,"DT")),ACRAPDA=$P(ACRDOCDT,U,10)
- Q:'ACRAPDA!'+ACRDOCDT!($P(ACRDOCDT,U,2)=1)
- S ACRINDV=$G(^ACRAPVS(ACRAPDA,"DT")),ACRINDV=$S($P(ACRINDV,U,6):$P(ACRINDV,U,6),1:$P(ACRINDV,U,2))
- Q:'ACRINDV
- ;Q:'$D(^VA(200,ACRINDV,0)) S X=$P(^(0),U),ACRINDV=$P($P(X,",",2)," ")_" "_$P(X,",") ;ACR*2.1*19.02 IM16848
- Q:'$D(^VA(200,ACRINDV,0)) S X=$$NAME2^ACRFUTL1(ACRINDV),ACRINDV=$P($P(X,",",2)," ")_" "_$P(X,",") ;ACR*2.1*19.02 IM16848
- N ACRJ
- D APDA^ACRFDISA
- I ACRZ>1 D Q:$D(ACRQUIT)!$D(ACROUT)
- .S DIR(0)="NO^1:"_ACRZ,DIR("A")="Respond to which message",DIR("B")=1
- .W !
- .D DIR^ACRFDIC
- .S ACRZ=+Y
- S DA=ACRAPDA
- S DIE="^ACRAPVS("
- S DR="[ACR RESPONSE]"
- D DDS^ACRFDIC
- I $D(ACRSCREN) K ACRSCREN W ! D DIE^ACRFDIC
- S ACRRESP=$G(^ACRAPVS(ACRAPDA,"RESP"))
- Q:$L(ACRRESP)<3
- D NOW^%DTC
- S ACRNOW=%
- S:ACRZ<1 ACRZ=1
- S:$D(^ACRAPVS(ACRAPDA,1,0))#2<1 ^ACRAPVS(ACRAPDA,1,0)="^9002190.01DA"
- I '$D(^ACRAPVS(ACRAPDA,1,ACRZ,0)) D
- .S X=ACRNOW,DIC="^ACRAPVS("_ACRAPDA_",1,",DA(1)=ACRAPDA,DIC(0)="L"
- .D FILE^ACRFDIC
- .S ACRZ=+Y
- S DIE="^ACRAPVS("_ACRAPDA_",1",DA(1)=ACRAPDA,DA=ACRZ,DR=".03////"_DUZ_";.04////"_ACRNOW
- D DIE^ACRFDIC
- S ^ACRAPVS(ACRAPDA,1,ACRZ,"RESP")=ACRRESP
- S DA=ACRDOCDA
- S DIE="^ACRDOC("
- S DR="[ACR RESPONSE COMPLETED]"
- D DDS^ACRFDIC
- Q:'$D(ACRSCREN)
- K ACRSCREN
- W !
- D DIE^ACRFDIC
- Q
- ACRFRESP ;IHS/OIRM/DSD/THL,AEF - ADD/EDIT APPROVAL RESPONSE; [ 09/23/2005 9:44 AM ]
- +1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**19**;NOV 05, 2001
- +2 ;;UTILITY ROUTINE TO ADD/EDIT APPROVAL RESPONSE
- RESP ;EP;TO PROCESS RESPONSE TO REQUEST FOR CHANGE OR CLARIFICATION OF A
- +1 ;REQUEST
- +2 NEW ACRDOCDT,ACRRESP,ACRINDV,ACRAPDA
- +3 DO RESP1
- +4 QUIT
- RESP1 SET ACRDOCDT=$GET(^ACRDOC(ACRDOCDA,"DT"))
- SET ACRAPDA=$PIECE(ACRDOCDT,U,10)
- +1 IF 'ACRAPDA!'+ACRDOCDT!($PIECE(ACRDOCDT,U,2)=1)
- QUIT
- +2 SET ACRINDV=$GET(^ACRAPVS(ACRAPDA,"DT"))
- SET ACRINDV=$SELECT($PIECE(ACRINDV,U,6):$PIECE(ACRINDV,U,6),1:$PIECE(ACRINDV,U,2))
- +3 IF 'ACRINDV
- QUIT
- +4 ;Q:'$D(^VA(200,ACRINDV,0)) S X=$P(^(0),U),ACRINDV=$P($P(X,",",2)," ")_" "_$P(X,",") ;ACR*2.1*19.02 IM16848
- +5 ;ACR*2.1*19.02 IM16848
- IF '$DATA(^VA(200,ACRINDV,0))
- QUIT
- SET X=$$NAME2^ACRFUTL1(ACRINDV)
- SET ACRINDV=$PIECE($PIECE(X,",",2)," ")_" "_$PIECE(X,",")
- +6 NEW ACRJ
- +7 DO APDA^ACRFDISA
- +8 IF ACRZ>1
- Begin DoDot:1
- +9 SET DIR(0)="NO^1:"_ACRZ
- SET DIR("A")="Respond to which message"
- SET DIR("B")=1
- +10 WRITE !
- +11 DO DIR^ACRFDIC
- +12 SET ACRZ=+Y
- End DoDot:1
- IF $DATA(ACRQUIT)!$DATA(ACROUT)
- QUIT
- +13 SET DA=ACRAPDA
- +14 SET DIE="^ACRAPVS("
- +15 SET DR="[ACR RESPONSE]"
- +16 DO DDS^ACRFDIC
- +17 IF $DATA(ACRSCREN)
- KILL ACRSCREN
- WRITE !
- DO DIE^ACRFDIC
- +18 SET ACRRESP=$GET(^ACRAPVS(ACRAPDA,"RESP"))
- +19 IF $LENGTH(ACRRESP)<3
- QUIT
- +20 DO NOW^%DTC
- +21 SET ACRNOW=%
- +22 IF ACRZ<1
- SET ACRZ=1
- +23 IF $DATA(^ACRAPVS(ACRAPDA,1,0))#2<1
- SET ^ACRAPVS(ACRAPDA,1,0)="^9002190.01DA"
- +24 IF '$DATA(^ACRAPVS(ACRAPDA,1,ACRZ,0))
- Begin DoDot:1
- +25 SET X=ACRNOW
- SET DIC="^ACRAPVS("_ACRAPDA_",1,"
- SET DA(1)=ACRAPDA
- SET DIC(0)="L"
- +26 DO FILE^ACRFDIC
- +27 SET ACRZ=+Y
- End DoDot:1
- +28 SET DIE="^ACRAPVS("_ACRAPDA_",1"
- SET DA(1)=ACRAPDA
- SET DA=ACRZ
- SET DR=".03////"_DUZ_";.04////"_ACRNOW
- +29 DO DIE^ACRFDIC
- +30 SET ^ACRAPVS(ACRAPDA,1,ACRZ,"RESP")=ACRRESP
- +31 SET DA=ACRDOCDA
- +32 SET DIE="^ACRDOC("
- +33 SET DR="[ACR RESPONSE COMPLETED]"
- +34 DO DDS^ACRFDIC
- +35 IF '$DATA(ACRSCREN)
- QUIT
- +36 KILL ACRSCREN
- +37 WRITE !
- +38 DO DIE^ACRFDIC
- +39 QUIT