- DVBCXFRS ;ALB/GTS-557/THM-STUFF C&P TRANSFER RESULTS ; 5/30/91 9:59 AM
- ;;2.7;AMIE;**10,193**;Apr 10, 1995;Build 84
- ;
- EN1 S (CNT,CNTA)=0 K OUT,FINISH
- F DVBCI=0:0 X XMREC S:XMRG["$END" FINISH=1 Q:XMER<0!(XMRG["$END") S XLN=XMRG,SUB=$E(XLN,2,5),XLN=$E(XLN,7,245) K OUT D @SUB Q:$D(OUT)
- K DFN,REQDT,EXMNM
- I '$D(FINISH) D BULL6^DVBCXFRD G EXIT ;sent to sender at orig site
- ;check to see if complete, if so send bulletins
- S NFINAL=0
- F EXMDA=0:0 S EXMDA=$O(^DVB(396.4,"C",REQDA,EXMDA)) Q:EXMDA="" S STAT=$P($G(^DVB(396.4,EXMDA,0)),U,4) I STAT'="C"&(STAT'["X") S NFINAL=1
- S CURSTAT=$S(CURSTAT]""&(CURSTAT["X"):CURSTAT,1:"T")
- I '$D(ALLROPN),NFINAL=0 S (DIC,DIE)="^DVB(396.3,",DA=REQDA,DR="17///"_CURSTAT_$S(RQCANCDT:";19////"_RQCANCDT,1:"") D ^DIE
- I NFINAL=0 S DFN=$P(^DVB(396.3,REQDA,0),U,1),REQDT=$P(^(0),U,2),PNAM=$P(^DPT(DFN,0),U,1),SSN=$P(^(0),U,9)
- I NFINAL=0 S XMB="DVBA C 2507 EXAM READY",XMB(1)=PNAM,XMB(2)=SSN,Y=REQDT X ^DD("DD") S XREQDT=Y,XMB(3)=XREQDT D ^XMB K XMB,XREQDT
- EXIT D DELSER^DVBCUTL4
- K FINISH,ALLROPN,CURSTAT,RQCANCDT,CANCBY,CANCDT,CANCREM,EXMPL,EXSTAT,FEXM
- K SITE,SITE1,SSN,STAT,SUB,PNAM,NFINAL,X,WRKSHT,USER,XLN,XMER,XMREC,XMRG,Y,ZH
- K CNT,CNTA,DATRETN,DTTRNSC,EXPHYS,EXMDT,EXMDA,EXM,DVBCI
- G KILL^DVBCUTIL
- ;
- USER S USER=$P(XLN,U,1),SITE=$P(XLN,U,2),SITE1=$P(XLN,U,3)
- Q
- ;
- RQDA S REQDA=+XLN,DTTRNSC=$P(XLN,U,2),CURSTAT=$P(XLN,U,3),RQCANCDT=$P(XLN,U,4)
- I '$D(^DVB(396.3,REQDA,0)) D BULL4^DVBCXFRD K DIC,DIE,DA,REQDA S OUT=1
- S (DIC,DIE)="^DVB(396.3,",DR="11////"_DTTRNSC,DA=REQDA D ^DIE K DIC,DIE,DR
- Q
- ;
- EXAM N DFN,REQDT,EXMNM S DFN=$P(^DVB(396.3,REQDA,0),U,1),REQDT=$P(^(0),U,2)
- S EXM=$P(XLN,U,1),WRKSHT=$P(XLN,U,2),EXSTAT=$P(XLN,U,3)
- S EXMNM=$P(^DVB(396.6,EXM,0),U,1),CNT=0
- S CANCREM=$P(XLN,U,4),CANCBY=$P(XLN,U,5),CANCDT=$P(XLN,U,6)
- S EXMDT=$P(XLN,U,7),EXPHYS=$P(XLN,U,8),FEXM=$P(XLN,U,9)
- S EXMPL=$P(XLN,U,10),DATRETN=$P(XLN,U,11)
- S DA=$O(^DVB(396.4,"APE",DFN,EXMNM,REQDT,0))
- I DA="" D BULL5^DVBCXFRD S OUT=1 Q
- S (DIC,DIE)="^DVB(396.4,"
- S DR=".05////"_WRKSHT_";.04////"_EXSTAT_";52////"_CANCREM_";51////"_CANCBY_";50////"_CANCDT_";.06////"_EXMDT_";.07////"_EXPHYS_";.08////"_FEXM_";.09////"_EXMPL_";63////"_DATRETN
- D ^DIE
- I $D(ALLROPN) K DR S DR="52///@;51///@;50///@" D ^DIE ;can't stuff nulls
- S NCN=0 F ZH=0:0 S ZH=$O(^DVB(396.4,"C",REQDA,ZH)) Q:ZH="" I $P(^DVB(396.4,ZH,0),U,4)="T" S NCN=1
- I NCN=0 S (DIC,DIE)="^DVB(396.3,",DA=REQDA,DR="31///@;34////"_DT D ^DIE
- K NCN,ZZ Q
- ;
- ROPN S ALLROPN=1,(DIC,DIE)="^DVB(396.3,",DA=REQDA
- S DR="11///@;31////y;34///@;17////2" ;AJF; Status Conversion
- D ^DIE ;transfers cancelled in error
- Q
- ;
- RSLT S DFN=$P(^DVB(396.3,REQDA,0),U,1)
- S DA=$O(^DVB(396.4,"APS",DFN,EXM,"C",0))
- I '$D(^DVB(396.4,DA,"RES",0)) S ^(0)="^^0^0^"_DT_"^^^^"
- I DA="" D BULL5^DVBCXFRD S OUT=1 Q
- S CNT=CNT+1,^DVB(396.4,DA,"RES",CNT,0)=XLN
- F X=3,4 S $P(^DVB(396.4,DA,"RES",0),U,X)=CNT
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCXFRS 2914 printed Feb 18, 2025@23:20:58 Page 2
- DVBCXFRS ;ALB/GTS-557/THM-STUFF C&P TRANSFER RESULTS ; 5/30/91 9:59 AM
- +1 ;;2.7;AMIE;**10,193**;Apr 10, 1995;Build 84
- +2 ;
- EN1 SET (CNT,CNTA)=0
- KILL OUT,FINISH
- +1 FOR DVBCI=0:0
- XECUTE XMREC
- if XMRG["$END"
- SET FINISH=1
- if XMER<0!(XMRG["$END")
- QUIT
- SET XLN=XMRG
- SET SUB=$EXTRACT(XLN,2,5)
- SET XLN=$EXTRACT(XLN,7,245)
- KILL OUT
- DO @SUB
- if $DATA(OUT)
- QUIT
- +2 KILL DFN,REQDT,EXMNM
- +3 ;sent to sender at orig site
- IF '$DATA(FINISH)
- DO BULL6^DVBCXFRD
- GOTO EXIT
- +4 ;check to see if complete, if so send bulletins
- +5 SET NFINAL=0
- +6 FOR EXMDA=0:0
- SET EXMDA=$ORDER(^DVB(396.4,"C",REQDA,EXMDA))
- if EXMDA=""
- QUIT
- SET STAT=$PIECE($GET(^DVB(396.4,EXMDA,0)),U,4)
- IF STAT'="C"&(STAT'["X")
- SET NFINAL=1
- +7 SET CURSTAT=$SELECT(CURSTAT]""&(CURSTAT["X"):CURSTAT,1:"T")
- +8 IF '$DATA(ALLROPN)
- IF NFINAL=0
- SET (DIC,DIE)="^DVB(396.3,"
- SET DA=REQDA
- SET DR="17///"_CURSTAT_$SELECT(RQCANCDT:";19////"_RQCANCDT,1:"")
- DO ^DIE
- +9 IF NFINAL=0
- SET DFN=$PIECE(^DVB(396.3,REQDA,0),U,1)
- SET REQDT=$PIECE(^(0),U,2)
- SET PNAM=$PIECE(^DPT(DFN,0),U,1)
- SET SSN=$PIECE(^(0),U,9)
- +10 IF NFINAL=0
- SET XMB="DVBA C 2507 EXAM READY"
- SET XMB(1)=PNAM
- SET XMB(2)=SSN
- SET Y=REQDT
- XECUTE ^DD("DD")
- SET XREQDT=Y
- SET XMB(3)=XREQDT
- DO ^XMB
- KILL XMB,XREQDT
- EXIT DO DELSER^DVBCUTL4
- +1 KILL FINISH,ALLROPN,CURSTAT,RQCANCDT,CANCBY,CANCDT,CANCREM,EXMPL,EXSTAT,FEXM
- +2 KILL SITE,SITE1,SSN,STAT,SUB,PNAM,NFINAL,X,WRKSHT,USER,XLN,XMER,XMREC,XMRG,Y,ZH
- +3 KILL CNT,CNTA,DATRETN,DTTRNSC,EXPHYS,EXMDT,EXMDA,EXM,DVBCI
- +4 GOTO KILL^DVBCUTIL
- +5 ;
- USER SET USER=$PIECE(XLN,U,1)
- SET SITE=$PIECE(XLN,U,2)
- SET SITE1=$PIECE(XLN,U,3)
- +1 QUIT
- +2 ;
- RQDA SET REQDA=+XLN
- SET DTTRNSC=$PIECE(XLN,U,2)
- SET CURSTAT=$PIECE(XLN,U,3)
- SET RQCANCDT=$PIECE(XLN,U,4)
- +1 IF '$DATA(^DVB(396.3,REQDA,0))
- DO BULL4^DVBCXFRD
- KILL DIC,DIE,DA,REQDA
- SET OUT=1
- +2 SET (DIC,DIE)="^DVB(396.3,"
- SET DR="11////"_DTTRNSC
- SET DA=REQDA
- DO ^DIE
- KILL DIC,DIE,DR
- +3 QUIT
- +4 ;
- EXAM NEW DFN,REQDT,EXMNM
- SET DFN=$PIECE(^DVB(396.3,REQDA,0),U,1)
- SET REQDT=$PIECE(^(0),U,2)
- +1 SET EXM=$PIECE(XLN,U,1)
- SET WRKSHT=$PIECE(XLN,U,2)
- SET EXSTAT=$PIECE(XLN,U,3)
- +2 SET EXMNM=$PIECE(^DVB(396.6,EXM,0),U,1)
- SET CNT=0
- +3 SET CANCREM=$PIECE(XLN,U,4)
- SET CANCBY=$PIECE(XLN,U,5)
- SET CANCDT=$PIECE(XLN,U,6)
- +4 SET EXMDT=$PIECE(XLN,U,7)
- SET EXPHYS=$PIECE(XLN,U,8)
- SET FEXM=$PIECE(XLN,U,9)
- +5 SET EXMPL=$PIECE(XLN,U,10)
- SET DATRETN=$PIECE(XLN,U,11)
- +6 SET DA=$ORDER(^DVB(396.4,"APE",DFN,EXMNM,REQDT,0))
- +7 IF DA=""
- DO BULL5^DVBCXFRD
- SET OUT=1
- QUIT
- +8 SET (DIC,DIE)="^DVB(396.4,"
- +9 SET DR=".05////"_WRKSHT_";.04////"_EXSTAT_";52////"_CANCREM_";51////"_CANCBY_";50////"_CANCDT_";.06////"_EXMDT_";.07////"_EXPHYS_";.08////"_FEXM_";.09////"_EXMPL_";63////"_DATRETN
- +10 DO ^DIE
- +11 ;can't stuff nulls
- IF $DATA(ALLROPN)
- KILL DR
- SET DR="52///@;51///@;50///@"
- DO ^DIE
- +12 SET NCN=0
- FOR ZH=0:0
- SET ZH=$ORDER(^DVB(396.4,"C",REQDA,ZH))
- if ZH=""
- QUIT
- IF $PIECE(^DVB(396.4,ZH,0),U,4)="T"
- SET NCN=1
- +13 IF NCN=0
- SET (DIC,DIE)="^DVB(396.3,"
- SET DA=REQDA
- SET DR="31///@;34////"_DT
- DO ^DIE
- +14 KILL NCN,ZZ
- QUIT
- +15 ;
- ROPN SET ALLROPN=1
- SET (DIC,DIE)="^DVB(396.3,"
- SET DA=REQDA
- +1 ;AJF; Status Conversion
- SET DR="11///@;31////y;34///@;17////2"
- +2 ;transfers cancelled in error
- DO ^DIE
- +3 QUIT
- +4 ;
- RSLT SET DFN=$PIECE(^DVB(396.3,REQDA,0),U,1)
- +1 SET DA=$ORDER(^DVB(396.4,"APS",DFN,EXM,"C",0))
- +2 IF '$DATA(^DVB(396.4,DA,"RES",0))
- SET ^(0)="^^0^0^"_DT_"^^^^"
- +3 IF DA=""
- DO BULL5^DVBCXFRD
- SET OUT=1
- QUIT
- +4 SET CNT=CNT+1
- SET ^DVB(396.4,DA,"RES",CNT,0)=XLN
- +5 FOR X=3,4
- SET $PIECE(^DVB(396.4,DA,"RES",0),U,X)=CNT
- +6 QUIT